Games of Daze/Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso/x2ftp/msdos/source/units/tokens.pas

Pascal/Delphi Source File | 1993-12-10 | 9.9 KB | 320 lines

UNIT Tokens;

INTERFACE

CONST     Tnil=0; { The batch is empty }
          Tpre=1; { Number prefix, #$%& }

          Tdel=2; { Collection of delimiters, SPACE TAB NL CR }
          Twrd=3; { Collection of letters, A-Z a-z ƥŠæ¢å    }
          Tnum=4; { Collection of numbers, if not prefixed    }
                  { ($#%&), then it is assumed decimal (#).   }
          Tunk=5; { Unknown token, only one character returns }

VAR       Translated:BOOLEAN;

FUNCTION  FrontStrip(S:STRING):STRING;
FUNCTION  Strip(S:STRING):STRING;
FUNCTION  NumToByte(Num:STRING):BYTE;
FUNCTION  NumToWord(Num:STRING):WORD;
FUNCTION  Roll(VAR S:STRING):CHAR;
FUNCTION  IsHex(Chr:CHAR):BOOLEAN;
FUNCTION  IsBin(Chr:CHAR):BOOLEAN;
FUNCTION  IsOct(Chr:CHAR):BOOLEAN;
FUNCTION  Len(S:STRING):BYTE;
PROCEDURE LowerCase(VAR Str:STRING);
PROCEDURE UpperCase(VAR Str:STRING);
FUNCTION  WhatChar(C:CHAR):BYTE;

PROCEDURE NextToken(VAR Batch,Token:STRING; VAR WhatToken:BYTE);

PROCEDURE OpenTokenFile(VAR Fil:TEXT; VAR A,B,C,D:STRING; VAR E:BYTE; VAR F:WORD);
PROCEDURE NextFileToken(VAR Fil:TEXT; VAR A,B,C:STRING; VAR D:BYTE; VAR E:WORD);
PROCEDURE NextFileChar(VAR Fil:TEXT; VAR A,B,C:STRING; VAR D:BYTE; VAR E:WORD);
PROCEDURE SkipFileString(VAR Fil:TEXT; VAR A,B,C:STRING; VAR D:BYTE; VAR E:WORD);
PROCEDURE CloseTokenFile(VAR Fil:TEXT);

IMPLEMENTATION

FUNCTION  FrontStrip(S:STRING):STRING;
 BEGIN
   WHILE (S[1]=' ') DO S:=COPY(S,2,Len(S)-1); FrontStrip:=S;
 END;

FUNCTION  Strip(S:STRING):STRING;
 BEGIN
   WHILE S[Len(S)]=' ' DO S:=COPY(S,1,Len(S)-1); Strip:=S;
 END;

FUNCTION  NumToByte(Num:STRING):BYTE;
 VAR T:BYTE; Meth:CHAR; Res:WORD;
 BEGIN
    Meth:=Roll(Num); NumToByte:=0; Translated:=FALSE;
    IF (Meth='$') AND (Len(Num)>2) THEN Exit; { $FF       }
    IF (Meth='#') AND (Len(Num)>3) THEN Exit; { #255      }
    IF (Meth='&') AND (Len(Num)>4) THEN Exit; { &377      }
    IF (Meth='%') AND (Len(Num)>8) THEN Exit; { %11111111 }
    Translated:=TRUE; UpperCase(Num); Res:=0;
    FOR T:=1 TO Len(Num) DO
     BEGIN
       IF Meth='%' THEN Res:=Res*2+(ORD(Num[T])-48);
       IF Meth='&' THEN Res:=Res*8+(ORD(Num[T])-48);
       IF Meth='#' THEN Res:=Res*10+(ORD(Num[T])-48);
       IF Meth='$' THEN IF Num[T]<='9' THEN Res:=Res*16+(ORD(Num[T])-48)
                                       ELSE Res:=Res*16+(ORD(Num[T])-55);
     END;
    NumToByte:=Res;
 END;

FUNCTION  NumToWord(Num:STRING):WORD;
 VAR T:BYTE; Meth:CHAR; Res:WORD;
 BEGIN
    Meth:=Roll(Num); NumToWord:=0; Translated:=FALSE;
    IF (Meth='$') AND (Len(Num)>4)  THEN Exit; { $FFFF             }
    IF (Meth='#') AND (Len(Num)>5)  THEN Exit; { #65535            }
    IF (Meth='&') AND (Len(Num)>6)  THEN Exit; { &177777           }
    IF (Meth='%') AND (Len(Num)>16) THEN Exit; { %1111111111111111 }
    Translated:=TRUE; UpperCase(Num); Res:=0;
    FOR T:=1 TO Len(Num) DO
     BEGIN
       IF Meth='%' THEN Res:=Res*2+(ORD(Num[T])-48);
       IF Meth='&' THEN Res:=Res*8+(ORD(Num[T])-48);
       IF Meth='#' THEN Res:=Res*10+(ORD(Num[T])-48);
       IF Meth='$' THEN IF Num[T]<='9' THEN Res:=Res*16+(ORD(Num[T])-48)
                                       ELSE Res:=Res*16+(ORD(Num[T])-55);
     END;
    NumToWord:=Res;
 END;

FUNCTION  Roll(VAR S:STRING):CHAR; ASSEMBLER;
 ASM
     PUSH DS            { Save DS }
     LDS  SI,S          { Get adress of string }
     MOV  AL,DS:[SI]    { Get string length }
     CMP  AL,0          { Exit if lenght of string is zero }
     JE   @Qt
     MOV  CH,AL         { Copy string length for shuffling }
     DEC  AL            { Decrease string length with one }
     MOV  DS:[SI],AL    { Stuff the length back into the specifier }
     INC  SI            { Prepare to shuffle letters one back }
     MOV  DH,DS:[SI]    { Get character to be returned }
@lp: MOV  AL,DS:[SI+1]  { Get next character }
     MOV  DS:[SI],AL    { Shuffle it back in }
     INC  SI            { Jump to next character }
     DEC  CH            { Mark character as shuffeled }
     CMP  CH,0          { Is there more characters to shuffle? }
     JG   @lp           { Yes, do the loop again. }
     MOV  AL,DH         { Return character shuffled out earlier }
@Qt: POP  DS            { Restore DS }
 END;

FUNCTION  IsHex(Chr:CHAR):BOOLEAN; ASSEMBLER;
 ASM
     MOV  AL,Chr
     MOV  AH,FALSE
     CMP  AL,048; JL  @Qt {0}
     CMP  AL,057; JLE @Ok {9}
     CMP  AL,065; JL  @Qt {A}
     CMP  AL,070; JLE @Ok {F}
     CMP  AL,097; JL  @Qt {a}
     CMP  AL,102; JG  @Qt {f}
@Ok: MOV  AH,TRUE
@Qt: MOV  AL,AH
 END;

FUNCTION  IsBin(Chr:CHAR):BOOLEAN; ASSEMBLER;
 ASM
     MOV  AL,Chr
     MOV  AH,FALSE
     CMP  AL,048; JL  @Qt {0}
     CMP  AL,049; JG  @Qt {1}
@Ok: MOV  AH,TRUE
@Qt: MOV  AL,AH
 END;

FUNCTION  IsOct(Chr:CHAR):BOOLEAN; ASSEMBLER;
 ASM
     MOV  AL,Chr
     MOV  AH,FALSE
     CMP  AL,048; JL  @Qt {0}
     CMP  AL,055; JG  @Qt {7}
@Ok: MOV  AH,TRUE
@Qt: MOV  AL,AH
 END;

FUNCTION  Len(S:STRING):BYTE; ASSEMBLER;
 ASM
     LES  SI,S
     MOV  AL,ES:[SI]
 END;

PROCEDURE LowerCase(VAR Str:STRING); ASSEMBLER;
 ASM
     LES  DI,Str
     MOV  CL,ES:[DI]
     INC  DI
@n0: MOV  AL,ES:[DI]
     CMP  AL,'Å'; JNE @n1; MOV  AL,'å'
@n1: CMP  AL,'¥'; JNE @n2; MOV  AL,'¢'
@n2: CMP  AL,'Æ'; JNE @n3; MOV  AL,'æ'
@n3: CMP  AL,'A'; JL  @n4
     CMP  AL,'Z'; JG  @n4
     XOR  AL,32
@n4: STOSB
     DEC CL
     CMP CL,0
     JGE @n0
 END;

PROCEDURE UpperCase(VAR Str:STRING); ASSEMBLER;
 ASM
     LES  DI,Str
     MOV  CL,ES:[DI]
     INC  DI
@n0: MOV  AL,ES:[DI]
     CMP  AL,'å'; JNE @n1; MOV  AL,'Å'
@n1: CMP  AL,'¢'; JNE @n2; MOV  AL,'¥'
@n2: CMP  AL,'æ'; JNE @n3; MOV  AL,'Æ'
@n3: CMP  AL,'a'; JL  @n4
     CMP  AL,'z'; JG  @n4
     XOR  AL,32
@n4: STOSB
     DEC CL
     CMP CL,0
     JGE @n0
 END;

FUNCTION  WhatChar(C:CHAR):BYTE; ASSEMBLER;
 ASM
     MOV  AH,C
     MOV  AL,Tdel         { Delimiters }
     CMP  AH,032; JE  @Qt
     CMP  AH,010; JE  @Qt
     CMP  AH,013; JE  @Qt
     CMP  AH,009; JE  @Qt
     MOV  AL,Tnum          { Numbers }
     CMP  AH,048; JL  @Nx
     CMP  AH,057; JLE @Qt
@Nx: MOV  AL,Twrd          { Letters }
     CMP  AH,065; JL  @Ny
     CMP  AH,090; JLE @Qt
     CMP  AH,097; JL  @Ny
     CMP  AH,122; JLE @Qt
     CMP  AH,134; JE  @Qt
     CMP  AH,143; JE  @Qt
     CMP  AH,145; JE  @Qt
     CMP  AH,146; JE  @Qt
     CMP  AH,155; JE  @Qt
     CMP  AH,157; JE  @Qt
@Ny: MOV  AL,Tpre          { Prefix }
     CMP  AH,035; JL  @Nz
     CMP  AH,038; JLE @Qt
@Nz: MOV  AL,Tunk          { Unknown }
@Qt:
 END;

{╔══════════════════════════════════════════════════════════════════════════╗
 ║ Handles one line at the time                                             ║
 ╚══════════════════════════════════════════════════════════════════════════╝}

PROCEDURE NextToken(VAR Batch,Token:STRING; VAR WhatToken:BYTE);
 BEGIN
   Token:=''; WhatToken:=Tnil; IF Len(Batch)=0 THEN Exit;
   IF WhatChar(Batch[1])=Tunk THEN
    BEGIN
      WhatToken:=Tunk; Token:=Roll(Batch); Exit;
    END;
   IF WhatChar(Batch[1])=Twrd THEN
    BEGIN
      WhatToken:=Twrd;
      WHILE (WhatChar(Batch[1])=Twrd) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
   IF WhatChar(Batch[1])=Tnum THEN
    BEGIN
      WhatToken:=Tnum; Token:='#';
      WHILE (WhatChar(Batch[1])=Tnum) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
   IF (WhatChar(Batch[1])=Tpre) AND (Batch[1]='#') THEN
    BEGIN
      WhatToken:=Tnum; Token:=Roll(Batch);
      WHILE (WhatChar(Batch[1])=Tnum) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
   IF (WhatChar(Batch[1])=Tpre) AND (Batch[1]='$') THEN
    BEGIN
      WhatToken:=Tnum; Token:=Roll(Batch);
      WHILE (IsHex(Batch[1])) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
   IF (WhatChar(Batch[1])=Tpre) AND (Batch[1]='%') THEN
    BEGIN
      WhatToken:=Tnum; Token:=Roll(Batch);
      WHILE (IsBin(Batch[1])) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
   IF (WhatChar(Batch[1])=Tpre) AND (Batch[1]='&') THEN
    BEGIN
      WhatToken:=Tnum; Token:=Roll(Batch);
      WHILE (IsOct(Batch[1])) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
   IF WhatChar(Batch[1])=Tdel THEN
    BEGIN
      WhatToken:=Tdel;
      WHILE (WhatChar(Batch[1])=Tdel) AND (Len(Batch)>0)
         DO Token:=Token+Roll(Batch); Exit;
    END;
 END;

{╔══════════════════════════════════════════════════════════════════════════╗
 ║ "Advanced" file-token handling                                           ║
 ╚══════════════════════════════════════════════════════════════════════════╝}

PROCEDURE OpenTokenFile(VAR Fil:TEXT; VAR A,B,C,D:STRING; VAR E:BYTE; VAR F:WORD);
 BEGIN                 { tokenfile , name , batch , token , origin, result , line }
    ASSIGN(Fil,A); RESET(Fil); READLN(Fil,B);
    C:=''; D:=B; E:=Tnil; F:=1;
 END;

PROCEDURE NextFileToken(VAR Fil:TEXT; VAR A,B,C:STRING; VAR D:BYTE; VAR E:WORD);
 BEGIN                 { tokenfile , batch , token , origin , result , line }
   NextToken(A,B,D);
   IF EOF(Fil) AND (D=Tnil) THEN
    BEGIN
      B:=''; A:=''; D:=Tnil; Exit;
    END ELSE
   IF D=Tnil THEN
    BEGIN
      READLN(Fil,A); INC(E); C:=A;
      B:=#10+#13; D:=Tdel;
    END;
 END;

PROCEDURE NextFileChar(VAR Fil:TEXT; VAR A,B,C:STRING; VAR D:BYTE; VAR E:WORD);
 BEGIN                { tokenfile , batch , token, origin , result , line }
   IF EOF(Fil) AND (Len(A)=0) THEN
    BEGIN
      B:=''; D:=Tnil; A:=''; Exit;
    END ELSE
   IF Len(A)=0 THEN
    BEGIN
      READLN(Fil,A); INC(E); C:=A;
    END;
   B:=Roll(A);
   D:=WhatChar(B[1]);
 END;

PROCEDURE SkipFileString(VAR Fil:TEXT; VAR A,B,C:STRING; VAR D:BYTE; VAR E:WORD);
 BEGIN                  { tokenfile, batch , token , origin , result , line }
   READLN(Fil,A); B:=#10+#13; C:=A; D:=Tdel; INC(E);
 END;

PROCEDURE CloseTokenFile(VAR Fil:TEXT);
 BEGIN
   CLOSE(Fil);
 END;

BEGIN
END.